home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / sysmacs.lisp < prev    next >
Encoding:
Text File  |  1992-05-30  |  6.1 KB  |  183 lines
  1. ;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: sysmacs.lisp,v 1.11 92/03/26 03:15:22 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;;    Miscellaneous system hacking macros.
  15. ;;;
  16. (in-package "LISP" :use '("SYSTEM" "DEBUG"))
  17.  
  18. (in-package "SYSTEM")
  19. (export '(without-gcing without-hemlock))
  20.  
  21. (in-package "LISP")
  22.  
  23.  
  24. ;;; WITH-ARRAY-DATA  --  Interface
  25. ;;;
  26. ;;;    Checks to see if the array is simple and the start and end are in
  27. ;;; bounds.  If so, it proceeds with those values.  Otherwise, it calls
  28. ;;; %WITH-ARRAY-DATA.  Note that there is a derive-type method for
  29. ;;; %WITH-ARRAY-DATA.
  30. ;;;
  31. (defmacro with-array-data (((data-var array &key (offset-var (gensym)))
  32.                 (start-var &optional (svalue 0))
  33.                 (end-var &optional (evalue nil)))
  34.                &rest forms)
  35.   "Given any Array, binds Data-Var to the array's data vector and Start-Var and
  36.   End-Var to the start and end of the designated portion of the data vector.
  37.   Svalue and Evalue are any start and end specified to the original operation,
  38.   and are factored into the bindings of Start-Var and End-Var.  Offset-Var is
  39.   the cumulative offset of all displacements encountered, and does not
  40.   include Svalue."
  41.   (once-only ((n-array array)
  42.           (n-svalue `(the index ,svalue))
  43.           (n-evalue `(the (or index null) ,evalue)))
  44.     `(multiple-value-bind
  45.      (,data-var ,start-var ,end-var ,offset-var)
  46.      (if (typep ,n-array '(simple-array * (*)))
  47.          ,(once-only ((n-len `(length ,n-array))
  48.               (n-end `(or ,n-evalue ,n-len)))
  49.         `(if (<= ,n-svalue ,n-end ,n-len)
  50.              (values ,n-array ,n-svalue ,n-end 0)
  51.              (%with-array-data ,n-array ,n-svalue ,n-evalue)))
  52.          (%with-array-data ,n-array ,n-svalue ,n-evalue))
  53.        (declare (ignorable ,offset-var))
  54.        ,@forms)))
  55.  
  56.  
  57. (defmacro without-gcing (&rest body)
  58.   "Executes the forms in the body without doing a garbage collection."
  59.   `(unwind-protect
  60.        (let ((*gc-inhibit* t))
  61.      ,@body)
  62.      (when (and *need-to-collect-garbage* (not *gc-inhibit*))
  63.        (maybe-gc nil))))
  64.  
  65. (defvar hi::*in-the-editor* nil)
  66.  
  67. (defmacro without-hemlock (&body body)
  68.   `(progn
  69.      (when (and hi::*in-the-editor* (null debug::*in-the-debugger*))
  70.        (let ((device (hi::device-hunk-device
  71.               (hi::window-hunk (hi::current-window)))))
  72.      (funcall (hi::device-exit device) device)))
  73.      ,@body
  74.      (when (and hi::*in-the-editor* (null debug::*in-the-debugger*))
  75.        (let ((device (hi::device-hunk-device
  76.               (hi::window-hunk (hi::current-window)))))
  77.      (funcall (hi::device-init device) device)))))
  78.  
  79.  
  80.  
  81. ;;; Eof-Or-Lose is a useful macro that handles EOF.
  82.  
  83. (defmacro eof-or-lose (stream eof-errorp eof-value)
  84.   `(if ,eof-errorp
  85.        (error "~S: Stream hit EOF unexpectedly." ,stream)
  86.        ,eof-value))
  87.  
  88. ;;; These macros handle the special cases of t and nil for input and
  89. ;;; output streams.
  90. ;;;
  91. (defmacro in-synonym-of (stream)
  92.   (let ((svar (gensym)))
  93.     `(let ((,svar ,stream))
  94.        (cond ((null ,svar) *standard-input*)
  95.          ((eq ,svar t) *terminal-io*)
  96.          (t (check-type ,svar stream)
  97.         ,svar)))))
  98.  
  99. (defmacro out-synonym-of (stream)
  100.   (let ((svar (gensym)))
  101.     `(let ((,svar ,stream))
  102.        (cond ((null ,svar) *standard-output*)
  103.          ((eq ,svar t) *terminal-io*)
  104.          (T (check-type ,svar stream)
  105.         ,svar)))))
  106.  
  107. ;;; With-Mumble-Stream calls the function in the given Slot of the Stream with
  108. ;;; the Args.
  109. ;;;
  110. (defmacro with-in-stream (stream slot &rest args)
  111.   `(let ((stream (in-synonym-of ,stream)))
  112.      (funcall (,slot stream) stream ,@args)))
  113.  
  114. (defmacro with-out-stream (stream slot &rest args)
  115.   `(let ((stream (out-synonym-of ,stream)))
  116.      (funcall (,slot stream) stream ,@args)))
  117.  
  118.  
  119. ;;;; These are hacks to make the reader win.
  120.  
  121. ;;; Prepare-For-Fast-Read-Char  --  Internal
  122. ;;;
  123. ;;;    This macro sets up some local vars for use by the Fast-Read-Char
  124. ;;; macro within the enclosed lexical scope.
  125. ;;;
  126. (defmacro prepare-for-fast-read-char (stream &body forms)
  127.   `(let* ((%frc-stream% (in-synonym-of ,stream))
  128.       (%frc-method% (stream-in %frc-stream%))
  129.       (%frc-buffer% (stream-in-buffer %frc-stream%))
  130.       (%frc-index% (stream-in-index %frc-stream%)))
  131.      (declare (type (or simple-string null) %frc-buffer%) (fixnum %frc-index%))
  132.      ,@forms))
  133.  
  134. ;;; Done-With-Fast-Read-Char  --  Internal
  135. ;;;
  136. ;;;    This macro must be called after one is done with fast-read-char
  137. ;;; inside it's scope to decache the stream-in-index.
  138. ;;;
  139. (defmacro done-with-fast-read-char ()
  140.   `(setf (stream-in-index %frc-stream%) %frc-index%))
  141.  
  142. ;;; Fast-Read-Char  --  Internal
  143. ;;;
  144. ;;;    This macro can be used instead of Read-Char within the scope of
  145. ;;; a Prepare-For-Fast-Read-Char.
  146. ;;;
  147. (defmacro fast-read-char (&optional (eof-errorp t) (eof-value ()))
  148.   `(cond
  149.     ((= %frc-index% in-buffer-length)
  150.      (setf (stream-in-index %frc-stream%) %frc-index%)
  151.      (prog1 (funcall %frc-method% %frc-stream% ,eof-errorp ,eof-value)
  152.         (setq %frc-index% (stream-in-index %frc-stream%))))
  153.     (t
  154.      (prog1 (aref %frc-buffer% %frc-index%)
  155.         (incf %frc-index%)))))
  156.  
  157. ;;;; And these for the fasloader...
  158.  
  159. ;;; Prepare-For-Fast-Read-Byte  --  Internal
  160. ;;;
  161. ;;;    Just like Prepare-For-Fast-Read-Char except that we get the Bin
  162. ;;; method.
  163. ;;;
  164. (defmacro prepare-for-fast-read-byte (stream &body forms)
  165.   `(let* ((%frc-stream% (in-synonym-of ,stream))
  166.       (%frc-method% (stream-bin %frc-stream%))
  167.       (%frc-buffer% (stream-in-buffer %frc-stream%))
  168.       (%frc-index% (stream-in-index %frc-stream%)))
  169.      (declare (type (or simple-array null) %frc-buffer%) (fixnum %frc-index%))
  170.      ,@forms))
  171.  
  172. ;;; Fast-Read-Byte, Done-With-Fast-Read-Byte  --  Internal
  173. ;;;
  174. ;;;    Identical to the text versions, but we get some gratuitous
  175. ;;; psuedo-generality by having different names.
  176. ;;;
  177. (defmacro done-with-fast-read-byte ()
  178.   `(done-with-fast-read-char))
  179. ;;;
  180. (defmacro fast-read-byte (&rest stuff)
  181.   `(fast-read-char ,@stuff))
  182.  
  183.